home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swags_z.zip / SOUND.SWG / 0017_Play SOUNDS in Background.pas < prev    next >
Pascal/Delphi Source File  |  1993-06-08  |  14KB  |  474 lines
  1. {  SEE XX34 modules at end of document !!!}
  2.  
  3. {$R-,F+}
  4.  
  5. {
  6.   ******************************************************************
  7.   BGSND.PAS
  8.  
  9.   Background Sound for Turbo Pascal
  10.  
  11.   Adapted from BGSND.INC for Turbo Pascal 3.0
  12.   by Michael Quinlan
  13.   9/17/85
  14.  
  15.   This version for Turbo Pascal 6.0
  16.   by Larry Hadley
  17.   3/20/93
  18.  
  19.   The routines are rather primitive, but could easily be extended.
  20.  
  21.   The sample routines included implement something similar to the
  22.   BASIC PLAY statement.
  23.   ******************************************************************
  24. }
  25. Unit BGSND;
  26.  
  27. INTERFACE
  28.  
  29. Uses
  30.    DOS;
  31.  
  32. CONST
  33.    BGSVer = '2.0';               { Unit version number }
  34.  
  35.    BGSPlaying :boolean = FALSE;  { TRUE while music is playing }
  36.  
  37. VAR
  38.    _BGSNumItems :integer;
  39.  
  40. procedure BGSPlay(n :integer; VAR items);
  41.  
  42. procedure _BGSStopPlay;
  43.  
  44. procedure PlayMusic(s :string);
  45.  
  46. IMPLEMENTATION
  47.  
  48. TYPE
  49.    BGSItem = RECORD
  50.                 cnt :word;     { count to load into the 8253-5 timer;
  51.                                  count = 1,193,180 / frequency }
  52.                 tics:integer;  { timer tics to maintain the sound;
  53.                                  18.2 tics per second }
  54.              end;
  55.  
  56.    _BGSItemP = ^BGSItem;
  57.  
  58. VAR
  59.    _BGSNextItem :_BGSItemP;
  60.    _BGSOldInt1C :pointer;
  61.    _BGSDuration :integer;
  62.    ExitSave     :pointer;
  63.  
  64. procedure _BGSsaveDS; external;      { saves ds as a CS:CONSTANT for use
  65.                                         within the int 1C vector }
  66. procedure _BGSPlayNextItem; external; { used by int 1C vector - selects next
  67.                                         note to play }
  68. procedure _BGSStopPlay; external;
  69.  
  70. procedure _BGSInt1C; external;        { int1C vector - hooks timer }
  71. {$L BGS.OBJ}
  72.  
  73. procedure BGSPlay(n :integer; VAR items);
  74. {
  75.   ***************************************************************************
  76.   You call this procedure to play music in the background. You pass the
  77.   number of sound segments, and an array with an element for each sound
  78.   segment. The array elements are two words each; the first word has the
  79.   count to be loaded into the timer (1,193,180 / frequency). The second word
  80.   has the duration of the sound segment, in timer tics (18.2 tics per second).
  81.   ***************************************************************************
  82. }
  83.   VAR
  84.      item_list : array[0..1000] of BGSItem ABSOLUTE items;
  85.   BEGIN
  86.      while BGSPlaying do { wait for previous sounds to finish } ;
  87.  
  88.      if n > 0 then
  89.      BEGIN
  90.         _BGSNumItems := n;
  91.         _BGSNextItem := Addr(item_list[0]);
  92.         BGSPlaying   := TRUE;
  93.         _BGSPlayNextItem;
  94.         _BGSsaveDS;
  95.         SetIntVec($1C, @_BGSInt1C);
  96.      END;
  97.   END;
  98.  
  99. procedure BGSErrorExit;
  100. {
  101.  **************************************************************************
  102.  In case there's an "oopsie" ... make sure that Int $1C is clean, and
  103.  music isn't playing.
  104.  **************************************************************************
  105. }
  106.   BEGIN
  107.      ExitProc := ExitSave;
  108.      if BGSPLaying then
  109.      BEGIN
  110.         _BGSStopPlay;
  111.         SetIntVec($1C, _BGSOldInt1C);
  112.      END;
  113.   END;
  114.  
  115. {
  116.  **************************************************************************
  117.  
  118.     BASIC PLAY Routines
  119.  
  120.  **************************************************************************
  121. }
  122.  
  123. {$R+}
  124.  
  125. VAR
  126.    MusicArea : array[1..255] of BGSItem; { contains sound segments }
  127.  
  128. {
  129.   frequency table from:
  130.   Peter Norton's Programmer's Guide to the IBM PC, p. 147
  131. }
  132. CONST
  133.    Frequency : array[0..83] of real =
  134. {    C        C#       D        D#       E        F        F#       G        G#       A        A#       B }
  135.   (32.70,   34.65,   36.71,   38.89,   41.20,   43.65,   46.25,   49.00,   51.91,   55.00,   58.27,   61.74,
  136.    65.41,   69.30,   73.42,   77.78,   82.41,   87.31,   92.50,   98.00,  103.83,  110.00,  116.54,  123.47,
  137.   130.81,  138.59,  146.83,  155.56,  164.81,  174.61,  185.00,  196.00,  207.65,  220.00,  233.08,  246.94,
  138.   261.63,  277.18,  293.66,  311.13,  329.63,  349.23,  369.99,  392.00,  415.30,  440.00,  466.16,  493.88,
  139.   523.25,  554.37,  587.33,  622.25,  659.26,  698.46,  739.99,  783.99,  830.61,  880.00,  932.33,  987.77,
  140.  1046.50, 1108.73, 1174.66, 1244.51, 1378.51, 1396.91, 1479.98, 1567.98, 1661.22, 1760.00, 1864.66, 1975.53,
  141.  2093.00, 2217.46, 2349.32, 2489.02, 2637.02, 2793.83, 2959.96, 3135.96, 3322.44, 3520.00, 3729.31, 3951.07
  142.   );
  143.  
  144. procedure PlayMusic(s :string);
  145. {
  146.   ***************************************************************************
  147.   Accept a string similar to the BASIC PLAY statement. The following are
  148.  
  149.   allowed:
  150.     A to G with optional #
  151.  
  152.     Plays the indicated note in the current octave.
  153.     A # following the letter indicates sharp.
  154.     A number following the letter indicates the length of the note
  155.     (4 = quarter note, 16 = sixteenth note, 1 = whole note, etc.).
  156.  
  157.     On
  158.  
  159.     Sets the octave to "n". There are 7 octaves, numbered 0 to 6. Each
  160.     octave goes from C to B. Octave 3 starts with middle C.
  161.  
  162.     Ln
  163.  
  164.     Sets the default length of following notes. L1 = whole notes, L2 = half
  165.     notes, etc. The length can be overridden for a specific note by follow-
  166.     ing the note letter with a number.
  167.  
  168.     Pn
  169.  
  170.     Pause. n specifies the length of the pause, just like a note.
  171.  
  172.     Tn
  173.  
  174.     Tempo. Number of quarter notes per minute. Default is 120.
  175.  
  176.     Period (.) terminates processing.
  177.  
  178.     Spaces are allowed between items, but not within items.
  179.   ***************************************************************************
  180. }
  181.  
  182.    VAR
  183.       i, n,            { i is the offset in the parameter string;
  184.                          n is the element number in MusicArea }
  185.       NoteLength,
  186.       Tempo,
  187.       CurrentOctave :integer;
  188.       cchar         :char;
  189.  
  190.    function GetNumber:integer;
  191.    {
  192.     **************************************************************************
  193.     get a number from the parameter string
  194.     increments i past the end of the number
  195.     **************************************************************************
  196.    }
  197.       VAR
  198.          n :integer;
  199.       BEGIN
  200.          n := 0;
  201.          WHILE (i <= length(s)) and (s[i] in ['0'..'9']) do
  202.          BEGIN
  203.             n := n*10+(Ord(s[i])-Ord('0'));
  204.             i := i+1;
  205.          end;
  206.          GetNumber := n;
  207.       END;
  208.  
  209.    procedure GetNote;
  210.    {
  211.     **************************************************************************
  212.     Input is a note letter. convert it to two sound segments -- one for the
  213.     sound then a pause following the sound.
  214.     increments i past the current item
  215.     **************************************************************************
  216.    }
  217.       VAR
  218.          note,
  219.          len  :integer;
  220.          l    :real;
  221.  
  222.       function CheckSharp(n :integer):integer;
  223.       {
  224.        ************************************************************************
  225.        check for a sharp following the letter. increments i if one found
  226.        ************************************************************************
  227.       }
  228.          BEGIN
  229.             if (i < length(s)) and (s[i] = '#') then
  230.             BEGIN
  231.                i := i + 1;
  232.                CheckSharp := n + 1
  233.             END
  234.             ELSE
  235.                CheckSharp := n;
  236.          END;  { CheckSharp }
  237.  
  238.       function FreqToCount(f : real) : integer;
  239.       {
  240.         ***********************************************************************
  241.         convert a frequency to a timer count
  242.         ***********************************************************************
  243.       }
  244.          BEGIN
  245.             FreqToCount := Round(1193180.0/f);
  246.          END;  { FreqToCount }
  247.  
  248.       BEGIN  { GetNote }
  249.          case cchar of
  250.           'A' : note := CheckSharp(9);
  251.           'B' : note := 11;
  252.           'C' : note := CheckSharp(0);
  253.           'D' : note := CheckSharp(2);
  254.           'E' : note := 4;
  255.           'F' : note := CheckSharp(5);
  256.           'G' : note := CheckSharp(7)
  257.          end; { case }
  258.  
  259.          MusicArea[n].cnt := FreqToCount(Frequency[(CurrentOctave*12)+note]);
  260.          if (s[i] in ['0'..'9']) and (i <= length(s)) then
  261.             len := GetNumber
  262.          else
  263.             len := NoteLength;
  264.          l := 18.2*60.0*4.0/(Tempo*len);
  265.          MusicArea[n].tics := Round(7.0*l/8.0);
  266.  
  267.          if MusicArea[n].tics = 0 then
  268.             MusicArea[n].tics := 1;
  269.          n := n + 1;
  270.          MusicArea[n].cnt := 0;
  271.          MusicArea[n].tics := Round(l/8.0);
  272.  
  273.          if MusicArea[n].tics = 0 then
  274.             MusicArea[n].tics := 1;
  275.          n := n + 1;
  276.       END;  { GetNote }
  277.  
  278.       procedure GetPause;
  279.       {
  280.        ************************************************************************
  281.        input is a pause. convert it to a silent sound segment.
  282.        increments i past the current item
  283.        ************************************************************************
  284.       }
  285.          VAR
  286.             len  :integer;
  287.             l    :real;
  288.  
  289.          BEGIN  { GetPause }
  290.             MusicArea[n].cnt := 0;
  291.             if (s[i] in ['0'..'9']) and (i <= length(s)) then
  292.                len := GetNumber
  293.             else
  294.                len := NoteLength;
  295.             l := 18.2*60.0*4.0/(Tempo*len);
  296.             MusicArea[n].tics := Round(l);
  297.             if MusicArea[n].tics = 0 then
  298.                MusicArea[n].tics := 1;
  299.             n := n + 1;
  300.          END;  { GetPause }
  301.  
  302.    BEGIN { PlayMusic }
  303.       NoteLength := 4;
  304.       Tempo := 120;
  305.       CurrentOctave := 3;
  306.  
  307.       n := 1;
  308.       i := 1;
  309.       while (i <= length(s)) and (s[i]<>'.') do
  310.       BEGIN
  311.          cchar := s[i];
  312.          i := i + 1;
  313.          case cchar of
  314.           'A'..'G' : GetNote;
  315.           'O'      : CurrentOctave := GetNumber;
  316.           'L'      : NoteLength    := GetNumber;
  317.           'P'      : GetPause;
  318.           'T'      : Tempo         := Getnumber
  319.          end; { case }
  320.       END;
  321.       BGSPlay(n-1, MusicArea)
  322.    END; { PlayMusic }
  323.  
  324. BEGIN { Unit init code }
  325.   ExitSave := ExitProc;
  326.   ExitProc := @BGSErrorExit;
  327.  
  328.   GetIntVec($1C, _BGSOldInt1C);
  329.  
  330.   Writeln('BGS v'+BGSVer);
  331. END.
  332.  
  333. (*   DEMO PROGRAM FOR BACKGROUND SOUND *)
  334.  
  335. {$M 1024, 0, 0}
  336. Program PlayBG;
  337.  
  338. Uses
  339.    DOS,
  340.    CRT,
  341.    BGSND;
  342.  
  343. VAR
  344.    F1              :text;
  345.    play_str, buf,
  346.    fname, progname :string;
  347.  
  348. Procedure Usage;
  349.    BEGIN
  350.       Writeln('PLAYBG <playfile>');
  351.       Writeln(#10+#13+'Where:');
  352.       Writeln(' <playfile> is the file containing the music you want played in');
  353.       Writeln('            the background');
  354.       Writeln(#10+#13+'The playfile contains a series of notes in ascii format');
  355.       Writeln;
  356.       Halt(1);
  357.    END;
  358.  
  359. {$I-}
  360. Function Exists(name:string):boolean;
  361.    VAR
  362.       F :file;
  363.    BEGIN
  364.       Assign(f, name);
  365.       Reset(f);
  366.       if IOresult<>0 then
  367.          Exists := FALSE
  368.       ELSE
  369.       BEGIN
  370.          Exists := TRUE;
  371.          Close(f);
  372.       END;
  373.    END;
  374. {$I+}
  375.  
  376. Function AskYN:boolean;
  377.    VAR
  378.       ch :char;
  379.    BEGIN
  380.       repeat
  381.          ch := ReadKey;
  382.          if ch = #0 then
  383.          BEGIN
  384.             ch := ReadKey;
  385.             ch := #0;
  386.          END;
  387.       until ch in ['y','Y','n','N'];
  388.       Write(ch);
  389.       case ch of
  390.         'Y','y' : AskYN := TRUE;
  391.         'N','n' : AskYN := FALSE;
  392.       END;
  393.    END;
  394.  
  395. BEGIN
  396.    Writeln('Background Play 1.0');
  397.  
  398.    if ParamCount<1 then
  399.       Usage;
  400.  
  401.    fname := ParamStr(1);
  402.    Assign(F1, fname);
  403.  
  404.    if (fname='') or not(Exists(fname)) then
  405.    BEGIN
  406.       Writeln('Invalid playfile.');
  407.       Halt(2);
  408.    END;
  409.  
  410.    play_str := '';
  411.    Reset(F1);
  412.  
  413.    repeat
  414.       ReadLn(F1, buf);
  415.       play_str := play_str+buf;
  416.    until Eof(F1) or (Length(play_str)>=200);
  417.  
  418.    Close(F1);
  419.  
  420.    Writeln(play_str);  {debug}
  421.    PlayMusic(play_str);
  422.  
  423.    Exec(GetEnv('COMSPEC'), '');
  424.  
  425.    if BGSPlaying then
  426.    BEGIN
  427.        Writeln('Music still playing - wait for it to finish?');
  428.        if Not(AskYN) then
  429.           _BGSStopPlay;
  430.        while BGSPLaying do;
  431.    END;
  432. END.
  433.  
  434. (*
  435.  
  436. XX34 Of OBJ CODE FILES.  Extract to separte files and use XX3401 to
  437. create BGS.OBJ and PLAYFIL.ASC.  Here is how to use :
  438.  
  439. 1. Copy first block to BGS.XX.
  440. 2. run XX3401 : XX3401 D BGS.XX.  This will create BGS.OBJ.
  441. 3. Copy second block to PLAYFIL.XX.
  442. 4. run XX3401 : XX3401 D PLAYFIL.XX
  443. 5. Write unit code to BGSND.PAS.  Compile.
  444. 6. Write demo code to PLAYSND.PAS Compile and run.
  445.  
  446.  
  447.  
  448. *XX3401-000674-210393--68--85-48874---------BGS.OBJ--1-OF--1
  449. U-U+3aIuL4ZWPJlWNrBjRKtYL47bQmt-IooeW0++++-IRL7WPm--QrBZPK7gNL6U63NZ
  450. QbBdPqsUAWskAMS65U-+uF6-RFcKNHdQOK7hL47bQqxpPaFQMaRn9Y3HHJ46+k-+uImK
  451. +U++O6U1+20VZ7M9++F2EJF--2F-J22Xa+Q+G++++UA-2tM9++F1HoF3-2BDF2IVa+Q+
  452. 8Bo+-+I-Icl3++lTEYRHHZJBGJF3HJA+13x0FpBCFJVIGJF3HE+ALo75IoxAF2ZCJ131
  453. ++lTEYRHF3JGEJF7Hos+0Y75Ip-AEJZ7HYQ+ZN+L+++023x0FpBEH23NHYJMJ2ZIFIp3
  454. +++XY-++++67Lo75IoZCJ131WE++Ad+F+++00Zx0FpBHFJF7HZE6+++tY-A+++6ALo75
  455. IpBIHp-EH23N8E++Pt+F+++00Zx0FpBHEJN3F3A0++-EW+E+E86-YO1T++60+0uA5U++
  456. mpK9v9U++6v+WoM8gEHqsMjsWoM4yei9FUWfysjZLQc4+9UQ+30V+U-EcE++I+vcnzzY
  457. MGHsta54-U+++AhJWymV++-6ck++g9PaEwEy+++aWULaEWO8FE5aEWO9FE8X+++aUno+
  458. R+PYMEk1ta52DU++XII2XA8X++073U6+WyJRmpK9v3-HIJ7KJls4ymuC5U++cE++G8A+
  459. +6Ay++++RGbYMGHsta41DU+++5IMi-k+I820+30V++-E1iV1zwM4++++ukKE1iVozkQT
  460. LptOKJhMWyJRnsmQLU12+pE0l0k4+ED2A+M-+wEz-U23l2Q4+E52GkM-+QFH-U20l4I4
  461. +EH2REM-+gFx-U20l624+E92ZZE0l7Y4+EH2bEM--AGV-U22l8s4+E52i+M-+wGw-U21
  462. lAI4+EJrWU6++5E+
  463. ***** END OF XX-BLOCK *****
  464.  
  465. {-------------------------  CUT HERE -------------------------------}
  466.  
  467. *XX3401-000047-210393--68--85-51905-----PLAYFIL.ASC--1-OF--1
  468. J1Uk62wo62ks62R4FIN5FoQUI1UUFYN4B0-5EY6o62R4FIN5FoQUFoN4FoN31Ec+
  469. ***** END OF XX-BLOCK *****
  470.  
  471. *)
  472.  
  473.  
  474.